home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / picks.com / PICKS.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1989-12-28  |  6.9 KB  |  181 lines
  1. unit PICKS;       { John Haluska, CIS 74000,1106   Turbo Pascal 4.0, 5.0 }
  2.  
  3. { Pick item from a vertical/horizontal bar menu by using the cursor keys to
  4.   high lite the menu item or entering the first non blank character of the
  5.   menu item.  Text and background colors may optionally be specified.
  6.  
  7.   To implement a pick menu:
  8.  
  9.     1.  Define the row, column location and title of each menu item (10
  10.         max).
  11.  
  12.         Pick[1].Row:=3;  Pick[1].Column:=2;  Pick[1].Title:=' A Choice ';
  13.               "                  "                   "            "
  14.         Pick[5].Row:=3;  Pick[5].Column:=30; Pick[5].Title:=' E Choice ';
  15.  
  16.     2.  Optional.  Specify the background and text colors.
  17.  
  18.         BkgdColor := Blue;   TextColor := LightGray;
  19.  
  20.     3.  Specify number of menu items, initial pick, display the menu, and
  21.         get the Result by calling:
  22.  
  23.         Result := DisplayMenuGetPick(1,5);          }
  24.  
  25. {$R-,S-,I+,D+,F-,V-,B-,N-,L+}
  26.  
  27. interface
  28.  
  29. uses
  30.   Crt;
  31. const
  32.   MaxPicks = 10;                               { Max number of picks in menu }
  33. type
  34.   pickmenu = record
  35.     Row           : integer;                              { location of pick }
  36.     Column        : integer;                               { in display menu }
  37.     Title         : string[60];                             { pick item name }
  38.   end;
  39.  
  40. var
  41.   Pick   : array[1..MaxPicks] of pickmenu;           { List of picks in menu }
  42.   TxtColor,BkgdColor  : byte;                        { Define display colors }
  43.  
  44. procedure CursorOn(State : boolean);
  45. function  DisplayMenuGetPick(InitPick,ActualPicks : integer) : integer;
  46.  
  47. implementation
  48.  
  49. {----------------------------------------------------------------------------}
  50. { CursorOn turns off (False) or turns on (True) the screen display cursor.
  51.   Example:  CursorOn(False)  turns off (hides) the cursor.  }
  52.  
  53. procedure CursorOn(State : boolean);
  54.  
  55. begin
  56.   inline(
  57.   $B4/$03/               {    MOV     AH,3          ;Call BIOS Service 3 -}
  58.   $B7/$00/               {    MOV     BH,0          ;  Get Cursor Position}
  59.   $CD/$10/               {    INT     $10           ;   & Size}
  60.   $8A/$96/>State/        {    MOV     DL,>State[BP] ;Save cursor on/off in DL}
  61.   $0A/$D2/               {    OR      DL,DL         ;Turn cursor off?}
  62.   $74/$06/               {    JZ      X1            ;Yes}
  63.   $81/$E1/$FF/$DF/       {    AND     CX,$DFFF      ;No, turn off bit 5 of CH}
  64.   $EB/$04/               {    JMP     SHORT X2  }
  65.   $81/$C9/$00/$20/       {X1: OR      CX,$2000      ;Yes, turn on bit 5 of CH}
  66.   $B4/$01/               {X2: MOV     AH,1          ;Call BIOS Service 1 -}
  67.   $CD/$10);              {    INT     $10           ;  Set Cursor Size}
  68. end;  {CursorOn}
  69. {-----------------------------------------------------------------------------}
  70. procedure HiLite(On : boolean; Pick : pickmenu);          { HiLite menu item }
  71.                                                          { Pick if On = True }
  72. begin
  73.   GoToXY(Pick.Column,Pick.Row);
  74.   if LastMode <> Mono then                                       { Color CRT }
  75.     if On then
  76.       begin
  77.         TextAttr := BkgdColor + TxtColor*16;                 { Reverse video }
  78.         Write(Pick.Title);
  79.         TextAttr := BkgdColor*16 + TxtColor;
  80.       end
  81.     else
  82.       begin
  83.         TextAttr := BkgdColor*16 + TxtColor;
  84.         Write(Pick.Title);
  85.       end
  86.   else                                                       { Monochrome CRT }
  87.     if On then
  88.       begin
  89.         TextAttr := LightGray*16 + Black;                     { Reverse video }
  90.         Write(Pick.Title);
  91.         TextAttr := Black*16 + LightGray;
  92.       end
  93.     else
  94.       begin
  95.         TextAttr := Black*16 + LightGray;
  96.         Write(Pick.Title);
  97.       end;
  98. end; {HiLite}
  99. {----------------------------------------------------------------------------}
  100. { Display a menu of ActualPicks items, generate string of pick first nonblank
  101.   characters with InitPick highlighted, and return selected Pick number.
  102.   Requires HiLite and CursorOn routines.  }
  103.  
  104. function DisplayMenuGetPick(InitPick,ActualPicks : integer) : integer;
  105.  
  106.  
  107. var
  108.   I : integer;
  109.   TempStr : string[80];
  110.   State : boolean;
  111.   Ch1,Ch2 : char;
  112.   Current,Last,FirstCharSel : integer;
  113.   FirstCharStr  : string[MaxPicks];
  114.  
  115. begin
  116.   FirstCharStr := '';
  117.   CursorOn(False);                                             { Hide cursor }
  118.   if LastMode <> Mono then
  119.     begin
  120.       TextAttr := TxtColor + BkgdColor*16;
  121.     end;
  122.   for I := 1 to ActualPicks do
  123.     with Pick[I] do
  124.       begin
  125.         GoToXY(Column,Row);
  126.         Write(Title);
  127.         TempStr := Title;
  128.         while (Length(TempStr) > 0) and (TempStr[1] = ' ') do       { Remove }
  129.           Delete(TempStr,1,1);                              { leading spaces }
  130.         FirstCharStr := FirstCharStr + Copy(TempStr,1,1);    { 1st non blank }
  131.       end;                                         { character in each title }
  132.   HiLite(True,Pick[InitPick]);                       { Define initial choice }
  133.   Current := InitPick;  Last := InitPick;  FirstCharSel := 0;
  134.   repeat
  135.     Ch1 := ReadKey;
  136.     case Ch1 of
  137.       #32..#127 : begin                                    { First Character }
  138.                     FirstCharSel := Pos(UpCase(Ch1),FirstCharStr);
  139.                     if FirstCharSel <> 0 then
  140.                       begin
  141.                         Last := Current; Current := FirstCharSel;
  142.                       end
  143.                     else Write(#7);                          { Beep if error }
  144.                   end;
  145.       #0 : begin
  146.              Ch2 := ReadKey;
  147.              case Ch2 of
  148.                #80,#77 : begin                            { Down/Right Arrow }
  149.                            Last := Current;
  150.                            if Last <> ActualPicks then Current := Last + 1
  151.                              else Current := 1;
  152.                          end;
  153.                #72,#75 : begin                               { Up/Left Arrow }
  154.                            Last := Current;
  155.                            if Last <> 1 then Current := Last - 1
  156.                              else Current := ActualPicks;
  157.                          end;
  158.  
  159.                #71,#73 : begin                                   { Home/PgUp }
  160.                            Last := Current;
  161.                            Current := 1;
  162.                          end;
  163.                #79,#81 : begin                                    { End/PgDn }
  164.                            Last := Current;
  165.                            Current := ActualPicks;
  166.                          end;
  167.              end;
  168.            end;
  169.     end;
  170.     HiLite(False,Pick[Last]);
  171.     HiLite(True,Pick[Current]);
  172.   until (Ch1 = #13) or (FirstCharSel <> 0);
  173.   CursorOn(True);                                            { Unhide cursor }
  174.   DisplayMenuGetPick:= Current;
  175. end; {DisplayMenuGetPick}
  176. {----------------------------------------------------------------------------}
  177. begin
  178.   BkgdColor := Black;
  179.   TxtColor := LightGray;
  180. end.
  181.